unit TableRest;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, Db, FMTBcd, SqlExpr;

type
  TTbl = class(TDataModule)
    OldTbl: TSQLDataSet;
    NewTbl: TSQLDataSet;
    OldTblFields: TSQLDataSet;
    NewTblFields: TSQLDataSet;
    OldFields: TSQLDataSet;
    NewFields: TSQLDataSet;
  private
    { Private declarations }
    function Tbl(DBType : Byte) : TDataSet;
    function TblFields(DBType : Byte) : TDataSet;
    function Fields(DBType : Byte) : TDataSet;

    function TableName(DBType : Byte): String;
    function FieldName(DBType : Byte): String;
    function FieldType(DBType : Byte): String;
    function IsComputed(DBType: Byte): Boolean;
    function ComputedType(DBType : Byte): String;
    function FieldSize(DBType : Byte): String;
    function FieldPrecision(DBType: Byte): String;
    function FieldScale(DBType: Byte): String;
    function FieldPos(DBType : Byte): String;
    function FieldNullProp(DBType: Byte): String;
    function IsFieldNull(DBType : Byte) : Boolean;
    function IsDomain(DBType : Byte): Boolean;
    function DomainName(DBType : Byte) : String;
    function FieldsEqualType : Boolean;
    function FieldsEqualNull: Boolean;
    procedure CreateField;
    procedure AlterFieldType;
    procedure AlterFieldProp;
    procedure CreateTable;
    function GetValue(FName: String; IsChar: Boolean): String;
  public
    { Public declarations }
    procedure CheckTable;
  end;

var
  Tbl: TTbl;

procedure CheckTables(ProgBar : TProgressBar);

implementation

uses Data, ReportForm;

{$R *.DFM}

procedure CheckTables;
begin
  ProgBar.Position:=0;
  // how many tables are there ?
  Tbl.NewTbl.CommandText:=
    'select count(*) as ccc from RDB$RELATIONS where '+
    'RDB$VIEW_SOURCE is NULL and RDB$SYSTEM_FLAG<>1';
  Tbl.NewTbl.Open;
  ProgBar.Max:=Tbl.NewTbl.fieldByName('ccc').AsInteger;
  Tbl.NewTbl.Close;

  Tbl.NewTbl.CommandText:=
    'select * from RDB$RELATIONS where '+
    'RDB$VIEW_SOURCE is NULL and RDB$SYSTEM_FLAG<>1';

  Tbl.NewTbl.Open;
  Tbl.OldTbl.Open;

  Tbl.NewTblFields.Prepared:=True;
  Tbl.NewTblFields.Open;
  Tbl.OldTblFields.Prepared:=True;
  Tbl.OldTblFields.Open;
  Tbl.NewFields.Open;
  Tbl.OldFields.Open;

  Tbl.NewTbl.First;
  While not Tbl.NewTbl.Eof do
  begin
    Application.ProcessMessages;
    ProgBar.Position:=ProgBar.Position+1;
    Tbl.CheckTable;
    Tbl.NewTbl.Next;
  end;

  Tbl.OldFields.Close;
  Tbl.NewFields.Close;
  Tbl.OldTblFields.Close;
  Tbl.NewTblFields.Close;
  Tbl.OldTbl.Close;
  Tbl.NewTbl.Close;

end;

{ TTbl }

function TTbl.Tbl(DBType: Byte): TDataSet;
begin
  case DBType of
    fcNew : Result:=NewTbl;
    fcOld : Result:=OldTbl;
  end;
end;

function TTbl.TblFields(DBType: Byte): TDataSet;
begin
  case DBType of
    fcNew : Result:=NewTblFields;
    fcOld : Result:=OldTblFields;
  end;
end;

function TTbl.Fields(DBType: Byte): TDataSet;
begin
  case DBType of
    fcNew : Result:=NewFields;
    fcOld : Result:=OldFields;
  end;
end;

function TTbl.TableName(DBType : Byte) : String;
begin
  Result:=Trim(Tbl(DBType).FieldByName('RDB$RELATION_NAME').AsString);
end;

function TTbl.FieldName(DBType : Byte) : String;
begin
  Result:=Trim(TblFields(DBType).FieldByName('RDB$FIELD_NAME').AsString);
end;

function TTbl.FieldSize(DBType : Byte) : String;
begin
  Result:=Fields(DBType).FieldByName('RDB$FIELD_LENGTH').AsString;
end;

function TTbl.FieldPrecision(DBType: Byte): String;
begin
  Result:=Fields(DBType).FieldByName('RDB$FIELD_PRECISION').AsString;
end;

function TTbl.FieldScale(DBType: Byte): String;
begin
  Result:=IntToStr(-Fields(DBType).FieldByName('RDB$FIELD_SCALE').AsInteger);
end;

function TTbl.FieldPos(DBType: Byte): String;
begin
  Result:=TblFields(DBType).FieldByName('RDB$FIELD_POSITION').AsString;
end;

function TTbl.FieldType(DBType : Byte): String;
begin
  Fields(DBType).Close;
  TSQLDataSet(Fields(DBType)).ParamByName('RNAME').AsString:=DomainName(DBType);
  Fields(DBType).Open;

  case Fields(DBType).FieldByName('RDB$FIELD_TYPE').AsInteger of
    7  : Result:='SMALLINT';
    8  : Result:='INTEGER';
    10 : Result:='FLOAT';
    12 : Result:='DATE'; // in dialect 3
    13 : Result:='TIME'; // in dialect 3
    14 : Result:='CHAR('+FieldSize(DBType)+')';
    16 : Result:='NUMERIC('+FieldPrecision(DBType)+','+FieldScale(DBType)+')';
    27 : Result:='DOUBLE PRECISION';
    35 : if DM.Dialect=1 then
           Result:='DATE' // in dialect 1
         else
           Result:='TIMESTAMP'; // in dialect 3
    37 : Result:='VARCHAR('+FieldSize(DBType)+')';
    261: Result:='BLOB SUB_TYPE '+Fields(DBType).FieldByName('RDB$FIELD_SUB_TYPE').AsString+
           ' SEGMENT SIZE '+Fields(DBType).FieldByName('RDB$SEGMENT_LENGTH').AsString;
  end;

end;

function TTbl.IsComputed(DBType: Byte): Boolean;
begin
  Fields(DBType).Locate('RDB$FIELD_NAME',DomainName(DBType),[]);
  Result:=Fields(DBType).FieldByName('RDB$COMPUTED_SOURCE').AsString<>'';
end;

function TTbl.ComputedType(DBType: Byte): String;
begin
  Result:=Fields(DBType).FieldByName('RDB$COMPUTED_SOURCE').AsString;
end;

function TTbl.IsDomain(DBType : Byte) : Boolean;
begin
  Result:=Copy(DomainName(DBType),1,4)<>'RDB$';
end;

function TTbl.DomainName(DBType : Byte) : String;
begin
  Result:=Trim(TblFields(DBType).FieldByName('RDB$FIELD_SOURCE').AsString);
end;

function TTbl.FieldNullProp(DBType : Byte) : String;
begin
  Result:=TblFields(DBType).FieldByName('RDB$NULL_FLAG').AsString;
end;

function TTbl.IsFieldNull(DBType : Byte): Boolean;
begin
  Result:=FieldNullProp(DBType)<>'1';
end;

function TTbl.GetValue(FName : String; IsChar: Boolean): String;
begin
  Result:=NewFields.FieldByName(FName).AsString;
  if Result='' then
    Result:='NULL'
  else
    if IsChar then Result:=#39+Result+#39;
end;

function TTbl.FieldsEqualType: Boolean;
begin
  if IsDomain(fcNew) then
  begin
    if IsDomain(fcOld) then
    begin
      // old field and new field has same domain, ok !
      Result:=DomainName(fcNew)=DomainName(fcOld);
    end else
      // new field has domain, old has not
      Result:=False;
  end else
  begin
    if not IsDomain(fcOld) then
    begin
      OldFields.Locate('RDB$FIELD_NAME',DomainName(fcOld),[]);
      NewFields.Locate('RDB$FIELD_NAME',DomainName(fcNew),[]);
      Result:=FieldType(fcOld)=FieldType(fcNew);
    end else
      // new field has not domain, but old has
      Result:=False;
  end;
end;

function TTbl.FieldsEqualNull: Boolean;
begin
  Result:=IsFieldNull(fcOld)=IsFieldNull(fcNew);
end;

procedure TTbl.AlterFieldType;
var S : String;
begin
  DM.SQL.Clear;
  if IsDomain(fcNew) then
  begin
    DM.SQL.Add('UPDATE RDB$RELATION_FIELDS set');
    S:='RDB$FIELD_SOURCE = '#39+DomainName(fcNew)+#39;
    DM.SQL.Add(S);
    DM.SQL.Add('WHERE RDB$FIELD_NAME = '#39+FieldName(fcNew)+#39' and');
    DM.SQL.Add('RDB$RELATION_NAME ='#39+TableName(fcNew)+#39);
  end else
  begin
    DM.SQL.Add('UPDATE RDB$FIELDS set');
    DM.SQL.Add('RDB$FIELD_TYPE = '+GetValue('RDB$FIELD_TYPE',False)+',');
    DM.SQL.Add('RDB$FIELD_SUB_TYPE = '+GetValue('RDB$FIELD_SUB_TYPE',False)+',');
    DM.SQL.Add('RDB$FIELD_LENGTH = '+GetValue('RDB$FIELD_LENGTH',False)+',');
    DM.SQL.Add('RDB$CHARACTER_LENGTH = '+GetValue('RDB$CHARACTER_LENGTH',False)+',');
    DM.SQL.Add('RDB$DEFAULT_VALUE = '+GetValue('RDB$DEFAULT_VALUE',False)+',');
    DM.SQL.Add('RDB$DESCRIPTION = '+GetValue('RDB$DESCRIPTION',True)+',');
    DM.SQL.Add('RDB$NULL_FLAG = '+GetValue('RDB$NULL_FLAG',False));
    DM.SQL.Add('WHERE RDB$FIELD_NAME = '#39+DomainName(fcOld)+#39);
  end;

  if DM.AutoRepair then
  begin
    try
      DM.ExecRunSQL;
      if DM.ShowReport then Rep.AddToReport('FIELD',Trim(TableName(fcNew))+'-'+Trim(FieldName(fcNew)),'different');
    except
      on E:Exception do
      begin
        ShowMessage(E.Message);
        if DM.ShowReport then Rep.AddToReport('FIELD',Trim(TableName(fcNew))+'-'+Trim(FieldName(fcNew)),'error');
      end;
    end;
  end else
  begin
    DM.AddToStrings('TABLE '+Trim(TableName(fcNew)),DM.SQL);
    if DM.ShowReport then Rep.AddToReport('FIELD',Trim(TableName(fcNew))+'-'+Trim(FieldName(fcNew)),'different');
  end;
end;

procedure TTbl.AlterFieldProp;
begin
  DM.SQL.Clear;
  DM.SQL.Add('UPDATE RDB$RELATION_FIELDS set');
  DM.SQL.Add('RDB$NULL_FLAG = '+FieldNullProp(fcNew));
  DM.SQL.Add('WHERE RDB$FIELD_NAME = '#39+FieldName(fcNew)+#39' and');
  DM.SQL.Add('RDB$RELATION_NAME ='#39+TableName(fcNew)+#39);

  if DM.AutoRepair then
  begin
    try
      DM.ExecRunSQL;
      if DM.ShowReport then Rep.AddToReport('FIELD',Trim(TableName(fcNew))+'-'+Trim(FieldName(fcNew)),'different');
    except
      if DM.ShowReport then Rep.AddToReport('FIELD',Trim(TableName(fcNew))+'-'+Trim(FieldName(fcNew)),'error');
    end;
  end else
  begin
    DM.AddToStrings('TABLE '+Trim(TableName(fcNew)),DM.SQL);
    if DM.ShowReport then Rep.AddToReport('FIELD',Trim(TableName(fcNew))+'-'+Trim(FieldName(fcNew)),'different');
  end;
end;

procedure TTbl.CreateField;
var S : String;
begin
  DM.SQL.Clear;
  if DM.Dialect=1 then
    DM.SQL.Add('ALTER TABLE '+TableName(fcNew))
  else
    DM.SQL.Add('ALTER TABLE "'+TableName(fcNew)+'"');

  if DM.Dialect=1 then
    S:='ADD '+FieldName(fcNew)+' '
  else
    S:='ADD "'+FieldName(fcNew)+'" ';

  if IsComputed(fcNew) then S:=S+' COMPUTED BY '+ComputedType(fcNew) else
  begin
    if IsDomain(fcNew) then
    begin
      if DM.Dialect=1 then
        S:=S+DomainName(fcNew)
      else
        S:=S+'"'+DomainName(fcNew)+'"';
    end else
      S:=S+FieldType(fcNew);
    if not IsFieldNull(fcNew) then S:=S+' NOT NULL ';
  end;
  DM.SQL.Add(S);

  if DM.AutoRepair then
  begin
    try
      DM.ExecRunSQL;
      if DM.ShowReport then Rep.AddToReport('FIELD',Trim(TableName(fcNew))+'-'+Trim(FieldName(fcNew)),'not exist');
    except
      if DM.ShowReport then Rep.AddToReport('FIELD',Trim(TableName(fcNew))+'-'+Trim(FieldName(fcNew)),'error');
    end;
  end else
  begin
    DM.AddToStrings('TABLE '+Trim(TableName(fcNew)),DM.SQL);
    if DM.ShowReport then Rep.AddToReport('FIELD',Trim(TableName(fcNew))+'-'+Trim(FieldName(fcNew)),'not exist');
  end;
end;

procedure TTbl.CreateTable;
var S : String;
begin
  DM.SQL.Clear;
  if DM.Dialect=1 then
    DM.SQL.Add('CREATE TABLE '+TableName(fcNew))
  else
    DM.SQL.Add('CREATE TABLE "'+TableName(fcNew)+'"');
  DM.SQL.Add('(');

  NewTblFields.First;
  While not NewTblFields.Eof do
  begin
    if DM.Dialect=1 then
      S:=FieldName(fcNew)+' '
    else
      S:='"'+FieldName(fcNew)+'" ';
    if IsComputed(fcNew) then S:=S+' COMPUTED BY ('+ComputedType(fcNew)+')' else
    begin
      if IsDomain(fcNew) then
      begin
        if DM.Dialect=1 then
          S:=S+DomainName(fcNew)
        else
          S:=S+'"'+DomainName(fcNew)+'"';
      end else
        S:=S+FieldType(fcNew);
      if not IsFieldNull(fcNew) then S:=S+' NOT NULL';
    end;
    NewTblFields.Next;
    if not NewTblFields.Eof then S:=S+',';
    DM.SQL.Add(S);
  end;

  DM.SQL.Add(')');

  if DM.AutoRepair then
  begin
    try
      DM.ExecRunSQL;
      if DM.ShowReport then Rep.AddToReport('TABLE',Trim(TableName(fcNew)),'not exist');
    except
      if DM.ShowReport then Rep.AddToReport('TABLE',Trim(TableName(fcNew)),'error');
    end;
  end else
  begin
    DM.AddToStrings('TABLE '+Trim(TableName(fcNew)),DM.SQL);
    if DM.ShowReport then Rep.AddToReport('TABLE',Trim(TableName(fcNew)),'not exist');
  end;
end;

procedure TTbl.CheckTable;
begin
  if NewTblFields.Active then NewTblFields.Close;
  NewTblFields.ParamByName('TNAME').AsString:=TableName(fcNew);
  NewTblFields.Open;

  OldTbl.Close;
  OldTbl.ParamByName('RName').AsString:=TableName(fcNew);
  OldTbl.Open;
  // does table exist ?
  if TableName(fcOld)=TableName(fcNew) then
  begin
    // now I have to check table fields
    OldTblFields.ParamByName('TNAME').AsString:=TableName(fcNew);

    NewTblFields.First;
    While not NewTblFields.Eof do
    begin
      OldTblFields.Close;
      OldTblFields.ParamByName('RName').AsString:=FieldName(fcNew);
      OldTblFields.Open;
      if FieldName(fcOld)=FieldName(fcNew) then
      begin
        // field exist, but is same type ?
        if not FieldsEqualType then AlterFieldType;
        if not FieldsEqualNull then AlterFieldProp;
      end
        else CreateField;
      NewTblFields.Next;
    end;
  end
    else CreateTable;
end;

end.
